home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-finimp.adb < prev    next >
Text File  |  1994-05-19  |  4KB  |  142 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --    S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N   --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.7 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Ada.Finalization; use Ada.Finalization;
  26.  
  27. package body System.Finalization_Implementation is
  28.  
  29.    ----------------
  30.    -- Initialize --
  31.    ----------------
  32.  
  33.    procedure Initialize (Object : in out Root_Controlled) is
  34.    begin
  35.       null;
  36.    end Initialize;
  37.  
  38.    --------------
  39.    -- Finalize --
  40.    --------------
  41.  
  42.    procedure Finalize (Object : in out Root_Controlled) is
  43.    begin
  44.       null;
  45.    end Finalize;
  46.  
  47.    ----------------
  48.    -- Initialize --
  49.    ----------------
  50.  
  51.    procedure Initialize (Object : in out Root_Limited_Controlled) is
  52.    begin
  53.       null;
  54.    end Initialize;
  55.  
  56.    --------------
  57.    -- Finalize --
  58.    --------------
  59.  
  60.    procedure Finalize (Object : in out Root_Limited_Controlled) is
  61.    begin
  62.       null;
  63.    end Finalize;
  64.  
  65.  
  66.    --------------------------
  67.    -- Attach_To_Final_List --
  68.    --------------------------
  69.  
  70.    procedure Attach_To_Final_List (
  71.      L   : in out Finalizable_Ptr;
  72.      Obj : in out Finalizable) is
  73.  
  74.    begin
  75.       if L /= null then
  76.          Obj.Next := L;
  77.          Finalizable (L.all).Previous := Empty_Root (Obj)'access;
  78.       else
  79.          Obj.Next := null;
  80.       end if;
  81.  
  82.       Obj.Previous := null;
  83.       L := Empty_Root (Obj)'access;
  84.    end Attach_To_Final_List;
  85.  
  86.    -------------------
  87.    -- Finalize_List --
  88.    -------------------
  89.  
  90.    procedure Finalize_List (L : Finalizable_Ptr) is
  91.       P     : Finalizable_Ptr := L;
  92.       Q     : Finalizable_Ptr;
  93.       Error : Boolean := False;
  94.  
  95.    begin
  96.       --  ??? pragma Abort_Defer;
  97.       while P /= null loop
  98.          Q := Finalizable (P.all).Next;
  99.          begin
  100.             Finalize (Root'Class (P.all));
  101.          exception
  102.             when others => Error := True;
  103.          end;
  104.          P := Q;
  105.       end loop;
  106.  
  107.       if Error then
  108.          raise Program_Error;
  109.       end if;
  110.    end Finalize_List;
  111.  
  112.    ------------------
  113.    -- Finalize_One --
  114.    ------------------
  115.  
  116.    procedure Finalize_One (
  117.      From   : in out Finalizable_Ptr;
  118.      Obj    : in out  Finalizable) is
  119.  
  120.    begin
  121.       --  ??? pragma Abort_Defer;
  122.       if Obj.Previous = null then
  123.  
  124.          --  It must be the first of the list
  125.          From := Obj.Next;
  126.       else
  127.  
  128.          Finalizable (Obj.Previous.all).Next := Obj.Next;
  129.       end if;
  130.  
  131.       if Obj.Next /= null then
  132.          Finalizable (Obj.Next.all).Previous := Obj.Previous;
  133.       end if;
  134.  
  135.       Finalize (Root'Class (Obj));
  136.  
  137.    exception
  138.       when others => raise Program_Error;
  139.    end Finalize_One;
  140.  
  141. end System.Finalization_Implementation;
  142.